001: # Here an extract of package MIME::Lite::HTML
002:
003: package MIME::Lite::HTML;
004:
005: # module MIME::Lite::HTML : Provide routine to transform a HTML page in
006: # a MIME::Lite mail
007: # Copyright 2001 A.Barbet alian@alianwebserver.com. All rights reserved.
008:
009: # Revision 1.1 2002/02/07 15:58:35 bettini
010: # added scanner for perl
011: #
012: # Revision 1.12 2002/01/07 20:18:53 alian
013: # - Add replace links for frame & iframe
014: # - Correct incorrect parsing in include_css for <LINK REL="SHORTCUT ICON">
015: # tag. Tks to doggy@miniasp.com for idea and patch
016: #
017: # Revision 1.11 2001/12/13 22:42:33 alian
018: # - Correct a bug with relative anchor
019: #
020: # Revision 1.10 2001/11/07 10:52:43 alian
021: # - Add feature for get restricted url. Add LoginDetails parameter for that
022: # (tks to Leon.Halford@ing-barings.com for idea)
023: # - Change error in POD doc rfc2257 => rfc2557 (tks to
024: # justin.zaglio@morganstanley.com)
025: # - Correct warning when $url_html is undef
026:
027: use LWP::UserAgent;
028: use HTML::LinkExtor;
029: use URI::URL;
030: use MIME::Lite;
031: use strict;
032: use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
033:
034: require Exporter;
035:
036: @ISA = qw(Exporter);
037: @EXPORT = qw();
038:
039: my $LOGINDETAILS;
040:
041: #------------------------------------------------------------------------------
042: # redefine get_basic_credentials
043: #------------------------------------------------------------------------------
044: {
045: package RequestAgent;
046: use vars qw(@ISA);
047: @ISA = qw(LWP::UserAgent);
048:
049: sub new
050: {
051: my $self = LWP::UserAgent::new(@_);
052: $self;
053: }
054:
055: sub get_basic_credentials
056: {
057: my($self, $realm, $uri) = @_;
058: # Use parameter of MIME-Lite-HTML, key LoginDetails
059: if (defined $LOGINDETAILS) { return split(':', $LOGINDETAILS, 2); }
060: # Ask user on STDIN
061: elsif (-t)
062: {
063: my $netloc = $uri->host_port;
064: print "Enter username for $realm at $netloc: ";
065: my $user = <STDIN>;
066: chomp($user);
067: # 403 if no user given
068: return (undef, undef) unless length $user;
069: print "Password: ";
070: system("stty -echo");
071: my $password = <STDIN>;
072: system("stty echo");
073: print "\n"; # because we disabled echo
074: chomp($password);
075: return ($user, $password);
076: }
077: # Damm we got 403 with CGI (use param LoginDetails) ...
078: else { return (undef, undef) }
079: }
080: }
081:
082: #------------------------------------------------------------------------------
083: # new
084: #------------------------------------------------------------------------------
085: sub new
086: {
087: my $class = shift;
088: my $self = {};
089: bless $self, $class;
090: my %param = @_;
091: # Agent name
092: $self->{_AGENT} = new RequestAgent;
093: $self->{_AGENT}->agent("MIME-Lite-HTML $VERSION");
094: $self->{_AGENT}->from('mime-lite-html@alianwebserver.com' );
095: # Set debug level
096: if ($param{'Debug'})
097: {
098: $self->{_DEBUG} = 1;
099: delete $param{'Debug'};
100: }
101: # Set Login information
102: if ($param{'LoginDetails'})
103: {
104: $LOGINDETAILS = $param{'LoginDetails'};
105: delete $param{'LoginDetails'};
106: }
107: # Set type of include to do
108: if ($param{'IncludeType'})
109: {
110: die "IncludeType must be in 'extern', 'cid' or 'location'\n" if
111: ( ($param{'IncludeType'} ne 'extern') and
112: ($param{'IncludeType'} ne 'cid') and
113: ($param{'IncludeType'} ne 'location'));
114: $self->{_include} = $param{'IncludeType'};
115: delete $param{'IncludeType'};
116: }
117: # Defaut type: use a Content-Location field
118: else {$self->{_include}='location';}
119:
120: ## Added by Michalis@linuxmail.org to manipulate non-us mails
121: if ($param{'TextCharset'}) {
122: $self->{_textcharset}=$param{'TextCharset'};
123: delete $param{'TextCharset'};
124: }
125: else { $self->{_textcharset}='iso-8859-1'; }
126: if ($param{'HTMLCharset'}) {
127: $self->{_htmlcharset}=$param{'HTMLCharset'};
128: delete $param{'HTMLCharset'};
129: }
130: else { $self->{_htmlcharset}='iso-8859-1'; }
131:
132: if ($param{'TextEncoding'}) {
133: $self->{_textencoding}=$param{'TextEncoding'};
134: delete $param{'TextEncoding'};
135: }
136: else { $self->{_textencoding}='7bit'; }
137:
138: if ($param{'HTMLEncoding'}) {
139: $self->{_htmlencoding}=$param{'HTMLEncoding'};
140: delete $param{'HTMLEncoding'};
141: }
142: else { $self->{_htmlencoding}='quoted-printable'; }
143: ## End. Default values remain as they were initially set.
144: ## No need to change existing scripts if you send US-ASCII.
145: ## If you DON't send us-ascii, you wouldn't be able to use
146: ## MIME::Lite::HTML anyway :-)
147:
148: # Set proxy to use to get file
149: if ($param{'Proxy'})
150: {
151: $self->{_AGENT}->proxy('http',$param{'Proxy'}) ;
152: print "Set proxy for http : ", $param{'Proxy'},"\n"
153: if ($self->{_DEBUG});
154: delete $param{'Proxy'};
155: }
156: # Set hash to use with template
157: if ($param{'HashTemplate'})
158: {
159: $param{'HashTemplate'} = ref($param{'HashTemplate'}) eq "HASH"
160: ? $param{'HashTemplate'} : %{$param{'HashTemplate'}};
161: $self->{_HASH_TEMPLATE}= $param{'HashTemplate'};
162: delete $param{'HashTemplate'};
163: }
164: $self->{_param} = \%param;
165: # Ok I hope I known what I do ;-)
166: MIME::Lite->quiet(1);
167: return $self;
168: }
169:
170: #------------------------------------------------------------------------------
171: # POD Documentation
172: #------------------------------------------------------------------------------
173:
174: =head1 NAME
175:
176: MIME::Lite::HTML - Provide routine to transform a HTML page in a MIME-Lite mail
177:
178: =head1 SYNOPSIS
179:
180: #!/usr/bin/perl -w
181: # A cgi program that do "Mail this page to a friend";
182: # Call this script like this :
183: # script.cgi?email=myfriend@isp.com&url=http://www.go.com
184: use strict;
185: use CGI qw/:standard/;
186: use CGI::Carp qw/fatalsToBrowser/;
187: use MIME::Lite::HTML;
188:
189: my $mailHTML = new MIME::Lite::HTML
190: From => 'MIME-Lite@alianwebserver.com',
191: To => param('email'),
192: Subject => 'Your url: '.param('url');
193:
194: my $MIMEmail = $mailHTML->parse(param('url'));
195: $MIMEmail->send; # or for win user : $mail->send_by_smtp('smtp.fai.com');
196: print header,"Mail envoye (", param('url'), " to ", param('email'),")<br>\n";
197:
198: =head1 DESCRIPTION
199:
200: This module is a Perl mail client interface for sending message that
201: support HTML format and build them for you..
202: This module provide routine to transform a HTML page in MIME::Lite mail.
203: So you need this module to use MIME-Lite-HTML possibilities
204:
205: =head2 What's happen ?
206:
207: The job done is:
208:
209: =over
210:
211: =item *
212:
213: Get the file (LWP) if needed
214:
215: =item *
216:
217: Parse page to find include images (gif, jpg, flash)
218:
219: =item *
220:
221: Attach them to mail with adequat header if asked (default)
222:
223: =item *
224:
225: Include external CSS,Javascript file
226:
227: =item *
228:
229: Replace relative url with absolute one
230:
231: =item *
232:
233: Build the final MIME-Lite object with each part found
234:
235: =back
236:
237: =cut